Poniższy kod działa tylko na mac os i ma sens jedynie gdy mamy niepolskie ustawienia dat i czasu a chcemy zmienić na polskie. W przypadku właściwych - polskich - ustawień nazwy dni i miesięcy powinny wyświetlać się nam po polsku. Jeśli nazwy są niepolskie kod zmieniający kolejność dni w punkcie o kalendarzach i mapach cieplnych nie będzie działał prawidłowo.
Według Dana Roama autora ksiażki “Narysuj swoje myśli” oś czasu jest modelem wizualnym ilustrującym odpowiedź na pytanie “kiedy” [@roam2010]. Najprościej stworzyć timeline używając funkcji geom_segment() ggplot2.
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.3 ✔ readr 2.1.4
## ✔ forcats 1.0.0 ✔ stringr 1.5.0
## ✔ ggplot2 3.5.0 ✔ tibble 3.2.1
## ✔ lubridate 1.9.3 ✔ tidyr 1.3.0
## ✔ purrr 1.0.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
Użyjemy danych dotyczących dat publikacji i liczby słów w książkach z sag A. Sapkowskiego i G.R.R. Martina.
fantasy <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/fantasy.csv")
## New names:
## Rows: 12 Columns: 6
## ── Column specification
## ──────────────────────────────────────────────────────── Delimiter: "," chr
## (2): title, author dbl (4): ...1, number, rok, words
## ℹ Use `spec()` to retrieve the full column specification for this data. ℹ
## Specify the column types or set `show_col_types = FALSE` to quiet this message.
## • `` -> `...1`
head(fantasy)
Poniższy wykres jest połączeniem wykresu lizakowego (lollypop chart) z osią czasu. Lizaki - słupki a właściwie odcinki zakończone punktem - oznaczać będą daty kolejnych książek
fantasy %>% filter(author == "Martin") %>%
# dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
geom_segment(aes(x = rok,
y = disloc,
xend = rok),
yend = 0) +
#rysuję oś czasu
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_text(aes(x = rok,
y = disloc,
label = title),
hjust = 1.0,vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = disloc)) +
# kontroluję etykiety na skali ręcznie wybierając tylko lata publikacji książek
scale_x_continuous(breaks = c(1996, 1999, 2000, 2005, 2011)) +
theme_minimal() +
theme(axis.title.x = element_blank(), #usuwa tytuł
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Did you mean to use `annotate()`?
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
Etykiety na skali można także wybrać na podstawie danych:
sapkowski <- fantasy %>%
filter(author == "Sapkowski") %>%
mutate(disloc = c(0.5, 1, -0.5, -1, 2)) #mniej punktów bo saga Sapkowskiego jest krótsza
ggplot(sapkowski) +
geom_segment(aes(x = rok,
y = disloc,
xend = rok),
yend = 0) +
#rysuję oś czasu
geom_segment(aes(x = 1990,
y = 0,
xend = 2003, #skracam oś czasu bo ostatnia książka jest z 1999
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_text(aes(x = rok,
y = disloc,
label = title),
hjust = 1.0,
vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = disloc)) +
#kontroluje etykiety na skali ręcznie wybierając tylko lata publikacji książek wykorzystując dane w ramce
scale_x_continuous(breaks = sapkowski$rok) +
theme_minimal() +
theme(axis.title.x = element_blank(), #usuwa tytuł
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2003, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 5 rows.
## ℹ Did you mean to use `annotate()`?
fantasy %>%
ggplot() +
geom_segment(aes(x = rok, y = words,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,
units = 'cm'),
type = 'closed')) +
geom_text(aes(x = rok,y = words,
label = title),
hjust = 1.0,
vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = words,
color = author)) +
theme_minimal() +
theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Did you mean to use `annotate()`?
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
Wykres panelowy.
fantasy %>%
ggplot() +
geom_segment(aes(x = rok, y = words,xend = rok),yend = 0) + # data = data trzeba ustawić globalnie
geom_segment(aes(x = 1993,y = 0,xend = 2012,yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_text(aes(x = rok,y = words,label = title), hjust = 0.5,vjust = - 0.5, size = 4) +
geom_point(aes(x = rok,
y = words)) +
scale_x_continuous(breaks = c(1994, 1995, 1996, 1997, 1999, 2000,2005, 2011)) +
scale_y_continuous(limits = c(0, 450000)) +
theme_bw() +
labs(y = "słowa") +
theme(axis.title.x = element_blank(), #usuwa podpis na osi x
#axis.title.y = element_blank(),
axis.text.y = element_blank(), # usuwa tekst etykiet na osi y
text = element_text(size = 15)) +
facet_wrap(~author, nrow =2)
## Warning in geom_segment(aes(x = 1993, y = 0, xend = 2012, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Did you mean to use `annotate()`?
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
Prosty przykład ramki danych z datami w formie znakowej.
timeline_data <- data.frame(event = c("Event 1", "Event 2"),
start = c("2020-06-06", "2020-10-01"),
end = c("2020-10-01", "2020-12-31"),
group = "My Events")
Na poniższym wykresie widać problem z właściwą interpretacją dat w formie napisów:
timeline_data %>%
ggplot() +
geom_segment(aes(y = event, #potrzebujemy esetyk y, yend i analogizni z x
xend = end,
x= start,
yend = event)) +
theme_bw()
Dlatego zamienimy napisy na daty funkcją as.Date:
timeline_data %>%
mutate(start = as.Date(start),
end = as.Date(end)) %>%
ggplot() +
geom_segment(aes(y = event,
xend = end,
x= start,
yend = event)) +
theme_bw()
Ponieważ w moim systeme daty ustawione są na amerykańskie zmieniam ustawienie na polskie.
Ten sam wykres będzie wyglądał inaczej.
timeline_data %>%
mutate(start = as.Date(start),
end = as.Date(end)) %>%
ggplot() +
geom_segment(aes(y = event,
xend = end,
x= start,
yend = event)) +
theme_bw()
Gantt w jednej linii
timeline_data %>%
mutate(start = as.Date(start),
end = as.Date(end)) %>%
ggplot() +
geom_segment(aes(y = group,
xend = end,
x= start,
yend = group,
colour = event)) +
scale_x_date() +
theme_bw()
Dane dotyczące długości trwania poszczególnych rządów w IIIRP za wikipedią:
premierzyIIIRP <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/premierzyIIIRP.csv")
## Rows: 22 Columns: 7
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (3): nazwisko, stronnictwo, stronnictwo2
## dbl (2): narodziny, śmierć
## date (2): start, end
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
View(premierzyIIIRP)
Jak widać w ostatniej komórce brakuje daty.
Dla uniknięcia problemów z rysowaniem linii można uzupełnić końcową komórkę w zmiennej end datą systemową funkcją Sys.Date, wewnątrz funkcji ymd z biblioteki lubridate. Komórka znajduje się w 7 kolumnie, w 22 wierszu więc robimy to tak:
premierzyIIIRP[22,7] <- lubridate::ymd(Sys.Date())
ggplot(premierzyIIIRP) +
geom_segment(aes(y = stronnictwo,
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo)) +
scale_x_date() +
theme_bw()
Uporządkujmy wykorzystując funkcję reorder:
ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo)) +
scale_x_date() +
theme_bw()
Ustalmy etykiety na osi y na zakończenia kadencji (premierzyIIIRP$end).
ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo)) +
scale_x_date(breaks = (premierzyIIIRP$end), # ustawiamy daty na osi x na koniec danego rządu
date_labels = "%Y") + #date_labels ustawione na rok
theme_bw() +
guides(colour = "none") # wyłączamy legendę
To nie jest dobre rozwiązanie bo daty się nakładają
Dlatego stworzymy wektor z unikalnymi datami rocznymi funkcjami unique i year.
kadencje <- unique(year(premierzyIIIRP$start))
Wektor który uzyskaliśmy ma format numeryczny.
class(kadencje)
## [1] "numeric"
Następnie zmienimy jego format na date
kadencje <- lubridate::ymd(kadencje,
truncated = 2L)
class(kadencje)
## [1] "Date"
plotly::ggplotly(ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo)) +
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
theme_bw() +
guides(colour = "none")
)
z <- ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end))) +
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
theme_bw()
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
plotly::ggplotly(z, tooltip = "text")
y <- ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end)),
linewidth = 10) + # poszerzymy lini
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
scale_color_brewer(palette = "Set3") +
labs(x = "",
y="",
title = "Rządy w III RP") +
theme_bw()
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
y
plotly::ggplotly(y, tooltip = "text") # dodatmy tekst do argumntu tooltip
Dodamy premierów
y1<- ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end)),
linewidth = 10) + # poszerzymy lini
geom_text(aes(y = reorder(stronnictwo, start),
x= start,
label = nazwisko)) +
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
scale_color_brewer(palette = "Set3") +
labs(x = "",
y="",
title = "Rządy w III RP") +
theme_bw()
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
y1
library(ggrepel)
ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end)),
linewidth = 10) + # poszerzymy lini
geom_text_repel(aes(y = reorder(stronnictwo, start),
x= start,
label = nazwisko)) +
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
scale_color_brewer(palette = "Set3") +
labs(x = "",
y="",
title = "Rządy w III RP") +
theme_bw() +
theme(panel.grid.minor = element_blank())
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
library(scales)
##
## Attaching package: 'scales'
## The following object is masked from 'package:purrr':
##
## discard
## The following object is masked from 'package:readr':
##
## col_factor
library(lubridate)
#install.packages("timevis")
library(timevis)
data <- data.frame(
id = 1:4,
content = c("Item one", "Item two",
"Ranged item", "Item four"),
start = c("2016-01-10", "2016-01-11",
"2016-01-20", "2016-02-14 15:00:00"),
end = c(NA, NA, "2016-02-04", NA)
)
timevis(data)
?timevis
premierzyIIIRP %>%
rename(content = nazwisko) %>%
rename(group = stronnictwo) %>% #argument groups i soubgroups pakitu timevis
timevis()
Użyjemy danych na temat sttrat sprzętu wojskowego w Ukrainie:
oryx <- read.csv("https://raw.githubusercontent.com/Tomasz-Olczyk/testowe-repozytrium/main/oryx.csv")
zajrzyjmy do danych:
glimpse(oryx)
## Rows: 664
## Columns: 2
## $ date <chr> "2022-02-24", "2022-02-25", "2022-02-26", "2022-02-27", "2022…
## $ change_3 <int> NA, 52, 55, 54, 160, 37, 112, 59, 93, 102, 94, 52, 75, 24, 40…
oryx$date jest wektorem napisów a oryx$change_3 liczb całkowitych z wartościami brakującymi
oryx %>%
mutate(date = as.Date(date)) %>%
complete(date = seq.Date(as.Date("2022-02-01"), #funkcja complete tworzy nowe obserwacje, funkcja seq.Date tworzy sekwencję dat
as.Date("2023-12-31"),
by="day")) %>%
mutate(month = month(date, label = TRUE),
wday = wday(date, label = TRUE),
day = day(date),
week = epiweek(date)) -> df1 #operator przypisania może działać także w drugą stronę
(x1 <- df1 %>%
ggplot(aes(x = wday, y = week, text = paste('straty: ', change_3))) +
geom_tile(aes(fill = change_3), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Sprzęt utracony na Ukrainie przez Rosjan - dane Oryx",
x = "",
y = "") +
scale_fill_continuous(low = "grey90",
high = "black",
name = "straty dzienne",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank())) +
guides(color = "none")
## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
Epiweek - tydzień zaczyna się od niedzieli:
?epiweek
Sprawdzamy kolejność dni:
levels(df1$wday)
## [1] "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"
oryx %>%
mutate(date = as.Date(date)) %>%
filter(date < "2023-01-01") %>%
complete(date = seq.Date(as.Date("2022-02-01"), as.Date("2022-12-31"), by="day")) %>%
mutate(month = month(date, label = TRUE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::isoweek(date)) -> df2
df2$wday <- factor(df2$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))
Kolejność dni w zmiennej czynnikowej wday musi być zmieniona bo isoweek zaczyna się w poniedziałk
df2$wday <- factor(df2$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))
Sprawdzamy kolejność dni:
levels(df2$wday)
## [1] "pon" "wto" "śro" "czw" "ptk" "sob" "ndz"
(x <- df2 %>%
ggplot(aes(x = wday, y = week, text = paste('straty: ', change_3))) +
geom_tile(aes(fill = change_3), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Sprzęt utracony na Ukrainie przez Rosjan - dane Oryx",
x = "",
y = "") +
scale_fill_continuous(low = "grey90",
high = "black",
name = "straty dzienne",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank())) +
guides(color = "none")
library(plotly)
##
## Attaching package: 'plotly'
## The following object is masked from 'package:ggplot2':
##
## last_plot
## The following object is masked from 'package:stats':
##
## filter
## The following object is masked from 'package:graphics':
##
## layout
ggplotly(x, tooltip = "text")
oryx %>%
mutate(date = as.Date(date)) %>%
#usunę filtrowani na roku
#filter(date < "2023-01-01") %>%
complete(date = seq.Date(as.Date("2022-01-01"), as.Date("2023-12-31"), by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::isoweek(date)) -> df2
isowek zaczyna się w poniedziałek:
df2$wday <- factor(df2$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))
ggplot(df2, aes(y = fct_rev(wday), x= week, fill = change_3)) +
geom_tile(width =7, height = 1, colour = "white")
ggplot(df2, aes(y = fct_rev(wday),
x= week,
fill = change_3)) +
geom_tile(colour = "white") +
scale_fill_gradient(low = "#BAE177", high ="#155219",
na.value = "gray88")
ggplot(df2, aes(y = fct_rev(wday),
x= week, fill = change_3)) +
geom_tile(colour = "white") +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "#BAE177",
high ="#155219",
na.value = "gray88") +
#coord_equal sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
theme_minimal()
ggplot(df2, aes(y = fct_rev(wday),
x= week, fill = change_3)) +
geom_tile(colour = "white") +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "#BAE177",
high ="#155219",
na.value = "gray88") +
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
theme_minimal() +
facet_wrap(~year, nrow =2)
ggplot(df2, aes(y = fct_rev(wday),
x= week, fill = change_3)) +
geom_tile(colour = "white") +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "#BAE177",
high ="#155219",
na.value = "gray88") +
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
theme_minimal() +
facet_wrap(~year, nrow = 2)
miesiące = as.data.frame(table(df2$month))
(y <- ggplot(df2, aes(y = fct_rev(wday),
x= week, fill = change_3)) +
geom_tile(colour = "white") +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "#BAE177",
high ="#155219",
na.value = "gray88") +
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =2.5, to = 52, by = 4.333),
labels = miesiące$Var1) +
theme_minimal() +
facet_wrap(~year, nrow = 2)
)
library(plotly)
ggplotly(y)
Stworzymy kalendarz wzorowany na kalendarzu aktywności na githubie.
Dane dotyczące ataków powietrznych na Ukrainę z Kaggle. Według opisu automatycznie ekstraktowane z komunikatów ukraińskich.
# zbiór missile_attacks z kaggle
ataki_rakietowe <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missile_attacks_daily.csv")
## Rows: 861 Columns: 10
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (7): time_start, model, launch_place, target, destroyed_details, carrie...
## dbl (2): launched, destroyed
## dttm (1): time_end
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
#zbiór missiles_and_uav
środki <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missiles_and_uav.csv")
## Rows: 35 Columns: 9
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (9): model, category, national_origin, type, launch_platform, name, name...
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
Łączymy ramkę danych z ramką opisującą typy środków napadu powietrznego żeby wyselekcjonować ataki z użyciem wybranego typu.
Wybieram model i category z ramki środki:
środki_s <- środki %>%
select(model, category)
Wybieram czas, model, wystrzelone z ramki ataki:
ataki_s <- ataki_rakietowe %>%
select(time_end, model,launched, destroyed)
Łączę lewym złączeniem (left_join)
ataki_środki <- left_join(ataki_s, środki_s)
## Joining with `by = join_by(model)`
ataki_środki <- ataki_środki %>%
mutate(date = as.Date(time_end)) %>%
complete(date = seq.Date(as.Date("2022-01-01"),
as.Date("2024-03-31"),
by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::isoweek(date))
Sumy ataków według kategorii
ataki_cat <- ataki_środki %>%
group_by(date, category) %>%
summarise(wystrzelone = sum(launched)) %>%
ungroup()
## `summarise()` has grouped output by 'date'. You can override using the
## `.groups` argument.
manewrujące <- ataki_cat %>%
filter(category == "cruise missile") %>%
select(date, wystrzelone)
manewrujące %>%
complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2024-03-30"), by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::epiweek(date)) -> df7
ggplot(df7, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "orange",
high ="red4",
na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = miesiące$Var1,
position = "bottom") +
theme_minimal() +
facet_wrap(~year, ncol = 1) +
theme(panel.grid = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.position = "bottom",
legend.justification = "right") +
guides(fill = guide_legend(title.position = "left",
label.position = "bottom",
keywidth = 1,
nrow = 1)) +
labs(title = "Rosyjskie ataki pociskami manewrującymi od 28 września 2022",
caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")
balistyczne <- ataki_cat %>%
filter(category == "ballistic missile") %>%
select(date, wystrzelone)
balistyczne %>%
complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2024-03-30"), by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::epiweek(date)) -> bdf
b <- ggplot(bdf, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "orange",
high ="red4",
na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = miesiące$Var1,
position = "bottom") +
theme_gray() +
facet_wrap(~year, ncol = 1) +
theme(panel.grid = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.position = "bottom",
legend.justification = "right") +
guides(fill = guide_legend(title.position = "left",
label.position = "bottom",
keywidth = 1,
nrow = 1)) +
labs(title = "Rosyjskie ataki pociskami balistycznymi od 28 września 2022",
caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")
b <- ggplot(bdf, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "orange",
high ="red4",
na.value = "gray") + #
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = miesiące$Var1,
position = "bottom") +
theme_minimal() +
facet_wrap(~year, ncol = 1) +
theme(axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.position = "bottom",
legend.justification = "right") +
guides(fill = guide_legend(title.position = "left",
label.position = "bottom",
keywidth = 1,
nrow = 1)) +
labs(title = "Rosyjskie ataki pociskami balistycznymi od 28 września 2022",
caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")
ggplotly(b)
## Warning in min(x): no non-missing arguments to min; returning Inf
## Warning in max(x): no non-missing arguments to max; returning -Inf
## Warning in matrix(g$fill_plotlyDomain, nrow = length(y), ncol = length(x), :
## data length [365] is not a sub-multiple or multiple of the number of rows [7]
## Warning in matrix(g$hovertext, nrow = length(y), ncol = length(x), byrow =
## TRUE): data length [365] is not a sub-multiple or multiple of the number of rows
## [7]
## Warning in colorscale_json(trace$colorscale): A colorscale list must of elements
## of the same (non-zero) length